home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / prefsHandling.tcl < prev    next >
Encoding:
Text File  |  1998-12-16  |  9.5 KB  |  398 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "prefsHandling.tcl"
  6.  #                                    created: 24/2/95 {9:52:30 pm} 
  7.  #                                last update: 16/12/1998 {2:13:31 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Reorganisation carried out by Vince Darley with much help from Tom 
  15.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  16.  # Alpha is shareware; please register with the author using the register 
  17.  # button in the about box.
  18.  #  
  19.  #  Description: 
  20.  # 
  21.  # Procedures for dealing with the user's preferences
  22.  # ###################################################################
  23.  ##
  24.  
  25. namespace eval mode {}
  26. namespace eval global {}
  27.  
  28. proc addArrDef {arr def val} {
  29.     addDef [list $arr $def] $val arr
  30. }
  31.  
  32. proc removeArrDef {arr def} {
  33.     removeDef [list $arr $def] arr
  34. }
  35.  
  36. proc addDef {def val {prefix {}}} {
  37.     global ${prefix}prefDefs
  38.     
  39.     readDefs $prefix
  40.     set ${prefix}prefDefs($def) $val
  41.     writeDefs $prefix
  42.     catch {unset ${prefix}prefDefs}
  43. }
  44.  
  45. proc removeDef {def {prefix {}}} {
  46.     global ${prefix}prefDefs
  47.     
  48.     readDefs $prefix
  49.     catch {unset ${prefix}prefDefs($def)}
  50.     writeDefs $prefix
  51.     catch {unset ${prefix}prefDefs}
  52. }
  53.  
  54. ##
  55.  # -------------------------------------------------------------------------
  56.  #
  57.  # "removeArr" --
  58.  #
  59.  #  Remove all elements of $arr from arrdefs.tcl
  60.  # -------------------------------------------------------------------------
  61.  ##
  62. proc removeArr {arr} {
  63.     global arrprefDefs $arr
  64.     
  65.     readDefs arr
  66.     foreach def [array names $arr] {
  67.     catch {unset arrprefDefs([list $arr $def])}
  68.     }
  69.     writeDefs arr
  70.     catch {unset arrprefDefs}
  71. }
  72.  
  73. proc addArr {arr} {
  74.     global arrprefDefs $arr
  75.     
  76.     readDefs arr
  77.     foreach def [array names $arr] {
  78.     catch {set arrprefDefs([list $arr $def]) [set ${arr}($def)]}
  79.     }
  80.     writeDefs arr
  81.     catch {unset arrprefDefs}
  82. }
  83.  
  84. proc readDefs {{prefix {}}} {
  85.     global PREFS
  86.     if {![file exists [file join $PREFS ${prefix}defs.tcl]]} return
  87.     uplevel \#0 [list source [file join $PREFS ${prefix}defs.tcl]]
  88. }
  89.  
  90. proc writeDefs {{prefix {}}} {
  91.     global HOME PREFS ${prefix}prefDefs 
  92.     
  93.     if {![info exists ${prefix}prefDefs]} {
  94.     catch {file delete [file join $PREFS ${prefix}defs.tcl]}
  95.     return
  96.     }
  97.     
  98.     if {![file exists "$PREFS"]} {
  99.     file mkdir "$PREFS"
  100.     }
  101.     set fd [open [file join $PREFS ${prefix}defs.tcl] "w"]
  102.     foreach nm [array names ${prefix}prefDefs] {
  103.     puts $fd [list set ${prefix}prefDefs($nm) [set ${prefix}prefDefs($nm)]]
  104.     }
  105.     close $fd
  106. }
  107.  
  108.  
  109. proc alpha::readUserDefs {} {
  110.     namespace eval :: {
  111.     global prefDefs arrprefDefs PREFS
  112.     
  113.     if {[file exists [file join $PREFS defs.tcl]]} {
  114.         source [file join $PREFS defs.tcl]
  115.         
  116.         foreach nm [array names prefDefs] {
  117.         global $nm
  118.         if {[catch {set $nm $prefDefs($nm)}]} {
  119.             set ns ""
  120.             while {[regexp "^($ns\[a-zA-Z_\]+::)" $nm ns]} {
  121.             namespace eval $ns {}
  122.             }
  123.             set $nm $prefDefs($nm)
  124.         }
  125.         
  126.         }
  127.         catch {unset prefDefs}
  128.     }
  129.     
  130.     if {[file exists [file join $PREFS arrdefs.tcl]]} {
  131.         source [file join $PREFS arrdefs.tcl]
  132.         
  133.         foreach nm [array names arrprefDefs] {
  134.         set arr [lindex $nm 0]
  135.         set field [lindex $nm 1]
  136.         set val $arrprefDefs($nm)
  137.         global $arr
  138.         set ${arr}($field) $val
  139.         if {[catch {set ${arr}($field) $val}]} {
  140.             set ns ""
  141.             while {[regexp "^($ns\[a-zA-Z_\]+::)" $arr ns]} {
  142.             namespace eval $ns {}
  143.             }
  144.             set ${arr}($field) $val
  145.         }
  146.         }
  147.         catch {unset arrprefDefs}
  148.     }
  149.     }
  150.     
  151. }
  152.  
  153. proc alpha::readUserPrefs {} {
  154.     global PREFS
  155.     # Use "prefs.tcl" to define or change any tcl information. 
  156.     if {![file exists [file join $PREFS prefs.tcl]]} {
  157.     if {![file exists "$PREFS"]} {
  158.         file mkdir "$PREFS"
  159.     }
  160.     set fd [open [file join $PREFS prefs.tcl] "w"]
  161.     close $fd
  162.     }
  163.     uplevel #0 {
  164.     if {[catch {source [file join $PREFS prefs.tcl]}]} {
  165.         if {[dialog::yesno "An error occurred while loading \"prefs.tcl\".  Shall I make a trace on the error?"]} {
  166.         dumpTraces "prefs.tcl error" $errorInfo
  167.         }
  168.     }
  169.     }
  170. }
  171.  
  172.     
  173. proc viewSavedSetting {} {
  174.     global prefDefs arrprefDefs
  175.     
  176.     saveModifiedVars
  177.     
  178.     set res [listpick -p "The following settings have been saved:" [getSavedSettings]]
  179.     
  180.     if {[regexp {([^(]+)\(([^)]+)\)} $res dummy arr field]} {
  181.     set arg [list $arr $field]
  182.     set val $arrprefDefs($arg)
  183.     } else {
  184.     global $res
  185.     set val $prefDefs($res)
  186.     }    
  187.     viewValue $res $val
  188.     unset prefDefs arrprefDefs
  189. }
  190.  
  191. proc viewValue {name val} {
  192.     set header "'$name's value is:"
  193.     set response "\r$val\r"
  194.     if {[string length $val] > 80} {
  195.     if {([llength $val] > 3) && ([llength $val] > 6 || [string length $val] > 160)} {
  196.         listpick -p "'$name's value is:" $val
  197.     } else {
  198.         if {[tclLog $header$response]} {
  199.         global tileLeft tileTop tileWidth
  200.         regsub -all : $name . name1
  201.         new -g $tileLeft $tileTop $tileWidth 100 -n "* $name1 *" -m Text
  202.         insertText "'$name's value is:\r\r$val\r"
  203.         winReadOnly
  204.         }
  205.     }
  206.     } else {
  207.     global mode
  208.     if {$mode == "Shel"} {
  209.         goto [maxPos]
  210.         tclLog $header$response
  211.         insertText [Alpha::Prompt]
  212.     } else {
  213.         alertnote "$header\r$response"
  214.     }
  215.     }
  216. }
  217.  
  218. ## 
  219.  # -------------------------------------------------------------------------
  220.  # 
  221.  # "removeSavedSetting" --
  222.  # 
  223.  #  This proc shouldn't 'unset' the variables it removes, because most
  224.  #  such variables will be in use/have default values until restart.
  225.  # -------------------------------------------------------------------------
  226.  ##
  227. proc removeSavedSetting {} {
  228.     global prefDefs arrprefDefs
  229.     
  230.     saveModifiedVars
  231.     set res [listpick -p "Remove which setting?" [lsort -ignore [getSavedSettings]]]
  232.     
  233.     if {$res == ""} return
  234.     if {[regexp {([^(]+)\(([^)]+)\)} $res dummy arr field]} {
  235.     global $arr
  236.     removeArrDef $arr $field
  237.     } else {
  238.     global $res
  239.     removeDef $res
  240.     }
  241.     
  242.     unset prefDefs arrprefDefs
  243. }
  244.  
  245.  
  246. proc getSavedSettings {} {
  247.     global prefDefs arrprefDefs
  248.     
  249.     readDefs
  250.     readDefs arr
  251.     
  252.     set names [array names prefDefs]
  253.     foreach pair [array names arrprefDefs] {
  254.     lappend names "[lindex $pair 0]([lindex $pair 1])"
  255.     }
  256.     
  257.     return [lsort $names]
  258. }
  259.  
  260. #===============================================================================
  261.  
  262. proc global::editPrefsFile {} {
  263.     global PREFS
  264.     if {![file exists [file join $PREFS prefs.tcl]]} {
  265.     set fd [open [file join $PREFS prefs.tcl] "w"]
  266.     close $fd
  267.     }
  268.     edit [file join $PREFS prefs.tcl]
  269. }
  270.  
  271. # Automatically add a line to the user input file
  272. proc addUserLine {line} {
  273.     global PREFS
  274.     
  275.     if {![file exists "$PREFS"]} {
  276.     file mkdir "$PREFS"
  277.     }
  278.     set fid [open [file join $PREFS prefs.tcl] "a+"]
  279.     if {![catch {seek $fid -1 end}]} {
  280.     if {[read $fid 1] == "\r"} {
  281.         set line "\r$line"
  282.     }
  283.     }
  284.     seek $fid 0 end
  285.     puts $fid $line
  286.     close $fid
  287. }
  288.  
  289. # Automatically add a line to a mode's pref file -trf
  290. proc mode::addUserLine {line} {
  291.     global PREFS mode
  292.     
  293.     if {![file exists "$PREFS"]} {
  294.     file mkdir "$PREFS"
  295.     }
  296.     set fid [open [file join $PREFS ${mode}prefs.tcl] "a+"]
  297.     if {![catch {seek $fid -1 end}]} {
  298.     if {[read $fid 1] != "\r"} {
  299.         set line "\r$line"
  300.     }
  301.     }
  302.     seek $fid 0 end
  303.     puts $fid $line
  304.     close $fid
  305. }
  306.  
  307.  
  308.  
  309. #===============================================================================
  310.  
  311. ## 
  312.  # -------------------------------------------------------------------------
  313.  # 
  314.  # "mode::sourcePrefs" --
  315.  # 
  316.  #  Fixes 'uplevel #0' problem
  317.  # -------------------------------------------------------------------------
  318.  ##
  319. proc mode::sourcePrefsFile {} { 
  320.     global mode PREFS
  321.     if {[file exists [file join ${PREFS} ${mode}Prefs.tcl]]} {
  322.     uplevel #0 [list source [file join ${PREFS} ${mode}Prefs.tcl]]
  323.     } else {
  324.     beep; message "Sorry, no preferences for '$mode' mode"
  325.     }
  326. }
  327.  
  328. proc mode::editPrefsFile {{m ""}} { 
  329.     global PREFS mode
  330.     if {$m == ""} { set m $mode }
  331.     message $m
  332.     # assume it is a mode, since we made the menu
  333.     
  334.     set f [file join $PREFS ${m}Prefs.tcl]
  335.     if {[file exists $f]} {
  336.     edit $f
  337.     } else {
  338.     if {[dialog::yesno "No '$m' prefs file exists, do you want to create one?"]} {
  339.         close [open $f "w"]
  340.         edit $f
  341.         insertText {
  342. ## 
  343.  # This    file will be sourced automatically, immediately after 
  344.  # the _first_ time the file which defines its mode is sourced.
  345.  # Use this file to insert your own mode-specific preferences
  346.  # and changes,    rather than altering the originals.
  347.  # 
  348.  # You can redefine menus, procedures, variables,...
  349.  ##
  350.  
  351.     }}}
  352.     
  353.     hook::callAll mode::editPrefsFile
  354.     }
  355.  
  356. proc saveModifiedVars {} {
  357.     global modifiedVars modifiedModeVars modifiedArrVars \
  358.       mode::features prefDefs modifiedArrayElements global::features
  359.     
  360.     cache::delete configuration
  361.     cache::add configuration variable global::features
  362.     
  363.     foreach f [lunique $modifiedArrVars] {
  364.     addArr $f
  365.     }
  366.     foreach f [lunique $modifiedVars] {
  367.     global $f
  368.     if {[info exists $f]} {
  369.         addDef $f [set $f]
  370.     } else {
  371.         removeDef $f
  372.     }
  373.     }
  374.     # these two lists actually behave identically
  375.     foreach f [concat [lunique $modifiedArrayElements]  [lunique $modifiedModeVars]] {
  376.     set elt [lindex $f 0]
  377.     set arr [lindex $f 1]
  378.     global $arr
  379.     if {[info exists [set arr]($elt)]} {
  380.         addArrDef [set arr] $elt [set [set arr]($elt)]
  381.     } else {
  382.         removeArrDef [set arr] $elt
  383.     }
  384.     }
  385.     
  386.     set modifiedVars {}
  387.     set modifiedArrVars {}
  388.     set modifiedModeVars {}
  389.     set modifiedArrayElements {}
  390. }
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  
  398.